package Object::_;

use strict;
use Hash::Util ();
use Sub::Name;

sub diag ($;@){
	printf STDERR shift, @_;
}


# Constructors.

sub new_hash {
	my $pkg = shift;
	require Hash::Util;
	my $h = {};
	#my ($s) = "$h" =~ /\((0x.+)\)/;$s = hex($s);
	my $self = bless $h,$pkg;
	&Hash::Util::lock_keys($self,$pkg->fields,@Object::ADD_FIELDS);
	#$self->{$Object::__IDENTITY_FIELD} = $s;
	return $self;
}

sub new_tie {
	my $pkg = shift;
	require Object::Tie unless $INC{'Object/Tie.pm'};
	my %h;
	tie %h, 'Object::Tie',
		$pkg,
		scalar $pkg->fields('public'),
		scalar $pkg->fields('private'),
		scalar $pkg->fields('protected'),
		\@Object::ADD_FIELDS
	;
	my $self = \%h;
	#my ($s) = "$self" =~ /\((0x.+)\)/;$s = hex($s);
	bless $self,$pkg;
	#$self->{$Object::__IDENTITY_FIELD} = $s;
	return $self;
}

# Initializers.

sub init_strict {
	package Object;
	my ($pkg,$self,$args) = @_;
	#Carp::carp "Strict init";
	my %chk = map { $_ => 1 } $self->fields;
	for (keys %$args) {
		if ($chk{$_}){
			$self->{$_} = $args->{$_};
		}else{
			Carp::croak "$pkg have no field $_";
		}
	}
}

sub init_soft {
	package Object;
	my ($pkg,$self,$args) = @_;
	#Carp::carp "Soft init";
	my %chk = map { $_ => 1 } $self->fields;
	for (keys %$args) {
		if ($chk{$_}){
			$self->{$_} = $args->{$_};
		}else{
			Carp::carp "$pkg have no field $_";
		}
	}
}

sub option {
	local $_ = shift;
	if (my $ref = ref) {
		if ($ref eq 'HASH') {
			return $_;
		}
		elsif ($ref eq 'ARRAY') {
			my %opts;
			@opts{@$_} = (1)x@$_;
			return \%opts;
		}
		else {
			die \("wrong reference: $ref");
		}
	}else{
		my @list = split /\s*[;,]\s*/;
		my %opts;
		@opts{@list} = (1)x@list;
		return \%opts;
	}
}

sub at {
	my $i = 0;
	while (my @c = caller($i++)) {
		next if $c[0] =~ /^Object(?:::.*|)$/;
		return join ' line ',@c[1,2];
	}
}

sub printc {
	my $prefix = @_ ? shift() . ': ' : '';
	my $i = 0;
	while (my @a = caller($i++)) {
		printf "%s %s line %s (%s / %s)\n",$prefix,@a[1,2,0,3];
	}
}

sub defined_can {
	no strict 'refs';
	my $pkg = shift;
	my $method = shift;
	my $sym = \%{$pkg.'::'};
	return 0 if (!exists $sym->{$method})
	         or ($sym->{$method} eq '-1')
	         or (!defined &{$sym->{$method}});
	return 1;
}
sub is_abstract {
	no strict 'refs';
	my $pkg = shift;
	my $method = shift;
	my $sym = \%{$pkg.'::'};
	return 1 if exists $sym->{$method}
	         and ($sym->{$method} eq '-1' or ( *{$sym->{$method}}{CODE} and !defined &{$sym->{$method}} ));
	return 0;
}

our %IMPLEMENTS_CHECK;
sub check_implements {
	my ($class,$at,@list) = @_;
	push @{ $IMPLEMENTS_CHECK{$class} ||= [] },{
		at => $at,
		list => \@list,
	};
}

sub check_implements_do {
	no strict 'refs';
	my @classes = @_ ? @_ : keys %IMPLEMENTS_CHECK;
	for my $class ( @classes ) {
		my $info = Object::Info->get($class);
		for my $block (@{ $IMPLEMENTS_CHECK{$class} }) {
			my $at = $block->{at};
			#diag "check (@{$block->{list}}) at $at\n";
			for my $iface (@{ $block->{list} }){
				my $isym = \%{ $iface.'::' };
				my $csym = \%{ $class.'::' };
				my @methods = grep { is_abstract($iface,$_) } keys %$isym;
				for (@methods) {
					unless (defined_can($class,$_)) {
						my $msg = "$class: wrong implementation of interface `$iface': method `$_' not implemented at $at\n";
						if ($info->check('implementation')) {
							die $msg;
						}else{
							warn $msg;
						}
					}
				};
			}
		}
	}
}

our %ACCESSORS;
sub make_accessors {
	my ($class,$at) = @_;
	$ACCESSORS{$class} = $at;
}
sub make_accessors_do {
	no strict 'refs';
	my @classes = @_ ? @_ : keys %ACCESSORS;
	for my $class ( @classes ) {
		my $info = Object::Info->get($class);
		my $check = $info->check('accessors');
		for my $type (qw(public protected private)) {
			next unless $info->opt('accessors',$type);
			for my $field ($info->$type) {
				*{ $class . '::' . $field } = subname $class.'::'.$field => (
					$check && $type ne 'public'
						? $type eq 'protected'
							? sub : lvalue { # protected
								my $clr = caller(0);
								return if $clr eq 'Object';
									# or $clr eq 'Object::_';
								Carp::croak "No access to $class( <$type>$field ) from $clr"
									if !( eval{ $clr->isa( $class ) } or eval{ $class->isa( $clr ) } );
								shift->{ $field }
							}
							: sub : lvalue { # private
								my $clr = caller(0);
								return if $clr eq 'Object';
									# or $clr eq 'Object::_';
								Carp::croak "No access to $class( <$type>$field ) from $clr"
									if $class ne $clr;
								shift->{ $field }
							}
						: sub : lvalue { shift->{ $field } }
				);
			}
		}
	}
	
}
CHECK {
	check_implements_do();
	make_accessors_do();
}

1;
